home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / tpb4_src.zip / DOWNLOAD.PAS < prev    next >
Pascal/Delphi Source File  |  1988-09-13  |  22KB  |  641 lines
  1. { TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen  
  2.   Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault  
  3.   
  4.   Last modified  ::  9-9-88 8:26 pm 
  5. }
  6.  
  7. {$R-}                             {Range checking off}
  8. {$B-}                             {Boolean complete evaluation off}
  9. {$S-}                             {Stack checking off}
  10. {$I+}                             {I/O checking on}
  11. {$N-}                             {No numeric coprocessor}
  12.  
  13. Unit Download;
  14.  
  15. Interface
  16.  
  17. Uses
  18.   TPCrt, Dos, TAccess, Globals, TPSTRING,
  19.   TPDOS, Core1, Core2, Dirs, Extract;
  20.   
  21.   
  22. procedure SendXmodem(sendmode : Char);
  23.  
  24.  
  25.   {==========================================================================}
  26.   
  27.   
  28. Implementation
  29.  
  30.  
  31.  
  32.   procedure Test_Download_Ratio(var ok_to_send : Boolean; fnum : Integer);
  33.   
  34.   var
  35.     Close           : Integer;
  36.     i, x            : LongInt;
  37.     
  38.   begin
  39.     if (user_rec.ratio > 0) and (ok_to_send) then
  40.       begin
  41.         case CreditType of
  42.           Points :
  43.             Close := 20;
  44.           Kilobytes :
  45.             Close := 100;
  46.           Files :
  47.             Close := 5;
  48.         end;
  49.         x := user_rec.Download;
  50.         x := x+fnum;
  51.         if x = 0 then
  52.           x := 1;
  53.         i := user_rec.upload+1;
  54.         if (((i*user_rec.ratio) div x) < 2) and (((i*user_rec.ratio) mod x)
  55.           < Close) then
  56.           begin
  57.             WriteLn(Com);
  58.             WriteLn(Com, 'You are getting close to your download limit.');
  59.             WriteLn(Com);
  60.           end;
  61.         if ((i*user_rec.ratio) div x) < 1 then
  62.           begin
  63.             ok_to_send := False;
  64.             WriteLn(Com);
  65.             WriteLn(Com, 'Unable to send files until some uploads are received.');
  66.             WriteLn(Com);
  67.           end;
  68.       end;
  69.   end;
  70.   
  71.   
  72.   procedure Update_Newin(Xfrname : DosFileName);
  73.   
  74.   var
  75.     i               : LongInt;
  76.     t               : tad_array;
  77.     
  78.   begin
  79.     SetSect(HomName);
  80.     FindKey(NewinName, i, Xfrname);
  81.     if OK then
  82.       begin
  83.         with nwin_rec do
  84.           begin
  85.             Seek(nwin_file, i);
  86.             Read(nwin_file, nwin_rec);
  87.             Inc(dnloads);
  88.             GetTAD(t);
  89.             last_dnload := t;
  90.             Seek(nwin_file, i);
  91.             Write(nwin_file, nwin_rec);
  92.             FlushAny(nwin_file)
  93.           end;
  94.       end;
  95.   end;
  96.   
  97.   
  98.   
  99.   procedure SendXmodem(sendmode : Char);
  100.     { Send a file using Xmodem protocol }
  101.     
  102.   var
  103.     OK, ok_to_send,
  104.     protocol_ok     : Boolean;
  105.     This            : FilePtr;
  106.     Xfrname,
  107.     TempXfrname     : DosFileName;
  108.     Batch_Xfrname   : Str100;
  109.     down_size       : string[8];
  110.     XfrFile         : untype_file;
  111.     mm, ss,
  112.     size, fnum,
  113.     pnum, tot_size  : Integer;
  114.     i, kblocks      : LongInt;
  115.     Fnames          : fname_array;
  116.     fsize           : array[1..10] of Integer;
  117.     mode            : StrPr;
  118.     tot_send_time   : Real;
  119.     
  120.     
  121.     
  122.     procedure Send_a_File;
  123.     
  124.     
  125.       procedure Call_Dsz(var Xfrname     : DosFileName;
  126.                          remaining       : LongInt;
  127.                          sendmode        : Char;
  128.                          var ok_to_send  : Boolean);
  129.                          
  130.       var
  131.         mm, ss,
  132.         time_on,
  133.         time_left       : Integer;
  134.         i               : LongInt;
  135.         
  136.       begin                       {Call_Dsz}
  137.         Str(rate, baud);
  138.         OK := True;
  139.         errcode := 0;
  140.         remaining := remaining div 128;
  141.         case sendmode of
  142.           'X' :
  143.             mode := 'Xmodem CRC';
  144.           'Y' :
  145.             mode := 'Ymodem';
  146.           'Z' :
  147.             mode := 'Zmodem';
  148.           'C' :
  149.             mode := 'Xmodem Checksum';
  150.           'Q' :
  151.             mode := 'Ymodem-G (Qmodem)';
  152.           'O' :
  153.             mode := 'Xmodem OverThruster';
  154.         end;
  155.         timer(time_on, time_left);
  156.         send_time(remaining, mm, ss);
  157.         kblocks := remaining div 8;
  158.         if remaining mod 8 <> 0 then
  159.           Inc(kblocks);
  160.         if mm > time_left then
  161.           begin
  162.             WriteLn(Com, 'Insufficient time remaining.');
  163.             SetSect(SetName);
  164.             OK := False
  165.           end;
  166.         if OK then
  167.           begin
  168.             case CreditType of
  169.               Points :
  170.                 begin
  171.                   FindKey(NewinName, i, Xfrname);
  172.                   if Taccess.OK then
  173.                     begin
  174.                       with nwin_rec do
  175.                         begin
  176.                           Seek(nwin_file, i);
  177.                           Read(nwin_file, nwin_rec);
  178.                           fnum := PointValue;
  179.                         end;
  180.                     end;
  181.                 end;
  182.               Kilobytes :
  183.                 fnum := kblocks;
  184.               Files :
  185.                 fnum := 1;
  186.             end;
  187.             Test_Download_Ratio(ok_to_send, fnum);
  188.             if (not ok_to_send) then
  189.               begin
  190.                 SetSect(SetName);
  191.                 OK := False
  192.               end;
  193.           end;
  194.         if OK then
  195.           begin
  196.             WriteLn(Com);
  197.             WriteLn(Com, yellow, 'Download Time:  ',
  198.               white, mm, ' minutes ', ss, ' seconds');
  199.             WriteLn(Com, yellow, 'Download Size:  ',
  200.               white, remaining, ' records, ', kblocks, ' 1k blocks');
  201.             if CreditType = Points then
  202.               WriteLn(Com, yellow, 'Cost of Files:  ', white, fnum, ' points');
  203.             WriteLn(Com, yellow, 'Protocol Type:  ', white, mode);
  204.             Write(Com, yellow, 'File Selected:  ', white, Xfrname);
  205.             if in_arc then
  206.               WriteLn(Com, green, ' (Use ''.ARC'' for your filename)')
  207.             else
  208.               WriteLn(Com);
  209.             WriteLn(Com);
  210.             WriteLn(Com, yellow, 'Several Ctrl-X''s Aborts Transfer');
  211.             WriteLn(Com, cyan);
  212.             SetSect(HomName);
  213.             Ch_Wait;
  214.             ScrollOn;
  215.             case sendmode of
  216.               'X', 'C' :
  217.                 mode := 'sx';
  218.               'Y' :
  219.                 mode := 'sx -k';
  220.               'Z' :
  221.                 mode := 'sz';
  222.               'Q' :
  223.                 mode := 'sx -g';
  224.               'O' :
  225.                 mode := 'so';
  226.               'B' :
  227.                 mode := 'sb -k';
  228.               'G' :
  229.                 mode := 'sb -g';
  230.             end;
  231.             errcode := ExecDos(DSZPath+' handshake on '+mode+' '+SetName
  232.               +'\'+Xfrname, False, nil);
  233.             if errcode = 0 then errcode := DosExitCode;
  234.             Ch_Init;
  235.             Ch_Set(rate);
  236.             ScrollOff;
  237.             SetSect(SetName);
  238.             if (not Ch_Carck) then
  239.               begin
  240.                 errcode := 1;
  241.                 SetSect(HomName);
  242.                 log(12, 'sending file');
  243.                 SetSect(SetName);
  244.                 mdhangup;
  245.                 remote_online := False;
  246.               end;
  247.           end;
  248.         if errcode <> 0 then
  249.           OK := False;
  250.         if OK then
  251.           begin
  252.             WriteLn(Com);
  253.             WriteLn(Com, 'Transfer sucessfully completed.');
  254.           end
  255.         else
  256.           ok_to_send := False;
  257.       end;                        {Call_Dsz}
  258.       
  259.       
  260.     begin                         {Send_a_File}
  261.       if in_library then
  262.         This := LibBase
  263.       else if in_arc then
  264.         This := ArcBase
  265.       else
  266.         This := DirBase;
  267.       while (This <> nil) and (Xfrname <> compress_fn(This^.fname)) do
  268.         This := This^.next;
  269.       if This <> nil then
  270.         begin
  271.           SetSect(HomName);
  272.           case sendmode of
  273.             'Z' :
  274.               log(15, Xfrname);
  275.             'G', 'Q' :
  276.               log(17, Xfrname)
  277.           else
  278.             log(5, Xfrname);
  279.           end;
  280.           SetSect(SetName);
  281.           if in_library then
  282.             begin
  283.               Assign(libr_file, LibReq);
  284.               Reset(libr_file, 1);
  285.               Seek(libr_file, (This^.index*128));
  286.               WriteLn(Com, 'Extracting member file...');
  287.               WriteLn(Com);
  288.               if (diskfree(Ord(Upcase(SetDrv[1]))-64) > (This^.fsize*128)) then
  289.                 ExtractLbr(Xfrname, (This^.fsize*128), ok_to_send)
  290.               else
  291.                 ok_to_send := False;
  292.               Close(libr_file);
  293.               if ok_to_send then
  294.                 begin
  295.                   SetSect(SetName);
  296.                   Assign(XfrFile, Xfrname);
  297.                   Reset(XfrFile, 1);
  298.                   SetSect(HomName);
  299.                   Call_Dsz(Xfrname, FileSize(XfrFile), sendmode, ok_to_send);
  300.                   Close(XfrFile);
  301.                   Erase(XfrFile);
  302.                 end;
  303.             end
  304.           else if in_arc then
  305.             begin
  306.               SetSect(HomName);
  307.               if ok_to_send then
  308.                 begin
  309.                   SetSect(HomName);
  310.                   WriteLn(Com, 'Extracting member file...');
  311.                   WriteLn(Com);
  312.                   ExtractArc(Xfrname, ok_to_send);
  313.                   if ok_to_send then
  314.                     begin
  315.                       SetSect(SetName);
  316.                       Assign(XfrFile, Xfrname);
  317.                       Reset(XfrFile, 1);
  318.                       SetSect(HomName);
  319.                       Call_Dsz(Xfrname, FileSize(XfrFile), sendmode, ok_to_send);
  320.                       Close(XfrFile);
  321.                       Erase(XfrFile);
  322.                     end;
  323.                 end;
  324.             end
  325.           else
  326.             begin
  327.               Assign(XfrFile, Xfrname);
  328.               Reset(XfrFile, 1);
  329.               SetSect(HomName);
  330.               Call_Dsz(Xfrname, FileSize(XfrFile), sendmode, ok_to_send);
  331.               Close(XfrFile)
  332.             end;
  333.           SetSect(HomName);
  334.           if ok_to_send then
  335.             begin
  336.               log(7, '');
  337.               case CreditType of
  338.                 Points :
  339.                   begin
  340.                     FindKey(NewinName, i, Xfrname);
  341.                     if Taccess.OK then
  342.                       begin
  343.                         with nwin_rec do
  344.                           begin
  345.                             Seek(nwin_file, i);
  346.                             Read(nwin_file, nwin_rec);
  347.                             user_rec.Download := user_rec.Download+PointValue;
  348.                           end;
  349.                       end;
  350.                   end;
  351.                 Kilobytes :
  352.                   user_rec.Download := user_rec.Download+kblocks;
  353.                 Files :
  354.                   Inc(user_rec.Download);
  355.               end;
  356.             end
  357.           else
  358.             log(8, '');
  359.         end
  360.       else
  361.         begin
  362.           WriteLn(Com, 'Could not locate ', Xfrname, ' in this file section.');
  363.           ok_to_send := False;
  364.           SetSect(HomName);
  365.           log(8, 'Not Found')
  366.         end;
  367.     end;                          {Send_a_File}
  368.     
  369.     
  370.   begin                           { SendXmodem }
  371.     if (not(sendmode in ['G', 'Q'])) then
  372.       protocol_ok := True
  373.     else if (not AllowMNP) then
  374.       protocol_ok := False
  375.     else if cmd_tail and (StUpcase(ParamStr(3)) = 'MNP') then
  376.       protocol_ok := (ParamStr(4) = '/Arq')
  377.     else if cmd_tail then
  378.       protocol_ok := True
  379.     else
  380.       protocol_ok := mnp;
  381.     ok_to_send := protocol_ok;
  382.     fnum := 0;                    {total number of files to send}
  383.     pnum := 0;                    {total number of points}
  384.     if (sendmode in ['G', 'B', 'Z']) and (not in_library) and (not in_arc) and (ok_to_send) then
  385.       begin
  386.         Batch_Xfrname := '';
  387.         WriteLn(Com);
  388.         case sendmode of
  389.           'Z' :
  390.             log(15, 'BATCH');
  391.           'G' :
  392.             log(17, 'BATCH')
  393.         else
  394.           log(5, 'BATCH');
  395.         end;
  396.         repeat
  397.           ok_to_send := Online;
  398.           if ok_to_send then
  399.             Xfrname := prompt('Filenames (wildcards ok)', 80, 'ES');
  400.           if (Xfrname <> ' ') and (ok_to_send) then
  401.             begin
  402.               This := DirBase;
  403.               Batch_Xfrname := Batch_Xfrname+' '+Xfrname;
  404.               Xfrname := Expand_Filename(Xfrname);
  405.               while (This <> nil) and (ok_to_send) do
  406.                 begin
  407.                   if fnum > 10 then
  408.                     ok_to_send := False;
  409.                   if (Equal_names(Xfrname, This^.fname)) and ok_to_send then
  410.                     begin
  411.                       Inc(fnum);
  412.                       Fnames[fnum] := compress_fn(This^.fname);
  413.                       fsize[fnum] := This^.fsize;
  414.                       if CreditType = Points then
  415.                         begin
  416.                           TempXfrname := Fnames[fnum];
  417.                           FindKey(NewinName, i, TempXfrname);
  418.                           if Taccess.OK then
  419.                             begin
  420.                               with nwin_rec do
  421.                                 begin
  422.                                   Seek(nwin_file, i);
  423.                                   Read(nwin_file, nwin_rec);
  424.                                   pnum := pnum+PointValue;
  425.                                 end;
  426.                             end;
  427.                         end;
  428.                     end;
  429.                   This := This^.next;
  430.                 end;
  431.             end;                  {xfrname<>' ' and ok to send}
  432.         until (Xfrname = ' ') or (not mult_cmds) or (not ok_to_send);
  433.         if (fnum > 0) and (fnum < 11) and (ok_to_send) then
  434.           begin
  435.             tot_size := 0;
  436.             tot_send_time := 0;
  437.             Batch_Xfrname := '';
  438.             for i := 1 to fnum do
  439.               begin
  440.                 size := fsize[i] shr 3; {divide by 8 recs / K}
  441.                 if fsize[i] mod 8 <> 0 then
  442.                   Inc(size);
  443.                 if Odd(size) then
  444.                   Inc(size);
  445.                 tot_size := tot_size+size;
  446.                 tot_send_time := tot_send_time+(fsize[i]*23.0/rate);
  447.                 Batch_Xfrname := Batch_Xfrname+' '+Fnames[i];
  448.               end;
  449.             mm := Trunc(tot_send_time);
  450.             ss := Round(60.0*Frac(tot_send_time));
  451.             WriteLn(Com);
  452.             WriteLn(Com, yellow, 'Total # Files:  ', white, fnum);
  453.             if CreditType = Points then
  454.               WriteLn(Com, yellow, 'Cost of Files:  ', white, pnum, ' points');
  455.             WriteLn(Com, yellow, 'Download Time:  ', white, mm, ' minutes ', ss, ' seconds');
  456.             WriteLn(Com, yellow, 'Download Size:  ', white, tot_size, 'k');
  457.             Write(Com, yellow, 'Protocol Type:  ', white);
  458.             case sendmode of
  459.               'B' :
  460.                 WriteLn(Com, 'Ymodem Batch');
  461.               'G' :
  462.                 WriteLn(Com, 'Ymodem-G Batch (DSZ)');
  463.               'Z' :
  464.                 WriteLn(Com, 'Zmodem');
  465.             end;
  466.             Write(Com, yellow, 'File Selected: ', white);
  467.             for i := 1 to Length(Batch_Xfrname) do
  468.               begin
  469.                 if (WhereX > 68) and (Batch_Xfrname[i] = ' ') then
  470.                   begin
  471.                     WriteLn(Com);
  472.                     Write(Com, '               ');
  473.                   end;
  474.                 Write(Com, Batch_Xfrname[i]);
  475.               end;
  476.             WriteLn(Com);
  477.             WriteLn(Com);
  478.             WriteLn(Com, yellow, 'Several Ctrl-X''s Aborts Transfer');
  479.             WriteLn(Com, cyan);
  480.             timer(time_on, time_left);
  481.             if time_left < mm then
  482.               begin
  483.                 WriteLn(Com, 'Not enough time for transfer.');
  484.                 ok_to_send := False;
  485.               end;
  486.           end                     {fnum>0 and fnum<11}
  487.         else                      {no filenames or too many files}
  488.           begin
  489.             ok_to_send := False;
  490.             if fnum > 10 then
  491.               WriteLn(Com, 'Max. of 10 Files.')
  492.             else
  493.               WriteLn(Com, 'No files by that name found in this section.');
  494.           end;
  495.         SetSect(HomName);
  496.         case CreditType of
  497.           Points :
  498.             fnum := pnum;
  499.           Kilobytes :
  500.             fnum := tot_size;
  501.         end;
  502.         if ok_to_send then
  503.           Test_Download_Ratio(ok_to_send, fnum);
  504.         if ok_to_send then
  505.           begin
  506.             Assign(ext_log, ZmdmLogName);
  507.             if ExistFile(ZmdmLogName) then
  508.               Erase(ext_log);
  509.             Ch_Wait;
  510.             ScrollOn;
  511.             case sendmode of
  512.               'Z' :
  513.                 mode := 'sz';
  514.               'B' :
  515.                 mode := 'sb -k';
  516.               'G' :
  517.                 mode := 'sb -g';
  518.             end;
  519.             SetSect(SetName);
  520.             errcode := ExecDos(DSZPath+' handshake on '+mode+' '+Batch_Xfrname, False, nil);
  521.             SetSect(HomName);
  522.             Ch_Init;
  523.             Ch_Set(rate);
  524.             ScrollOff;
  525.             Delay(1000);
  526.             WriteLn(Com);
  527.             ok_to_send := False;
  528.             Assign(ext_log, ZmdmLogName);
  529.             {$I-}
  530.             Reset(ext_log) {$I-} ;
  531.             if IoResult = 0 then
  532.               begin
  533.                 while not EoF(ext_log) do
  534.                   begin
  535.                     ReadLn(ext_log, ext_log_rec);
  536.                     if (not(ext_log_rec[1] in ['E', 'L'])) then
  537.                       begin
  538.                         ok_to_send := True;
  539.                         repeat
  540.                           Delete(ext_log_rec, 1, 1)
  541.                         until Pos(' ', ext_log_rec) <> 1;
  542.                         down_size := '';
  543.                         repeat
  544.                           down_size := down_size+ext_log_rec[1];
  545.                           Delete(ext_log_rec, 1, 1);
  546.                         until ext_log_rec[1] = ' ';
  547.                         Delete(ext_log_rec, 1, 42);
  548.                         OK := Str2Long(down_size, kblocks);
  549.                         if OK then
  550.                           kblocks := kblocks div 1024
  551.                         else
  552.                           kblocks := 0;
  553.                         if Pos(' ', ext_log_rec) <> 0 then
  554.                           Delete(ext_log_rec, Pos(' ', ext_log_rec), 10);
  555.                         Xfrname := ext_log_rec;
  556.                         if in_arc then
  557.                           Update_Newin(ArcReq)
  558.                         else if in_library then
  559.                           Update_Newin(LibReq)
  560.                         else
  561.                           Update_Newin(Xfrname);
  562.                         case sendmode of
  563.                           'Z' :
  564.                             log(15, Xfrname);
  565.                           'G' :
  566.                             log(17, Xfrname)
  567.                         else
  568.                           log(5, Xfrname);
  569.                         end;
  570.                         case CreditType of
  571.                           Points :
  572.                             begin
  573.                               FindKey(NewinName, i, Xfrname);
  574.                               if Taccess.OK then
  575.                                 begin
  576.                                   with nwin_rec do
  577.                                     begin
  578.                                       Seek(nwin_file, i);
  579.                                       Read(nwin_file, nwin_rec);
  580.                                       user_rec.Download := user_rec.Download+PointValue;
  581.                                     end;
  582.                                 end;
  583.                             end;
  584.                           Kilobytes :
  585.                             user_rec.Download := user_rec.Download+kblocks;
  586.                           Files :
  587.                             Inc(user_rec.Download);
  588.                         end;
  589.                       end
  590.                     else
  591.                       ok_to_send := False;
  592.                   end;
  593.                 Close(ext_log);
  594.               end;
  595.             if ok_to_send then
  596.               begin
  597.                 log(7, 'BATCH');
  598.                 WriteLn(Com, 'Batch Transfer Complete.');
  599.               end
  600.             else
  601.               begin
  602.                 log(8, 'BATCH');
  603.                 WriteLn(Com, 'Aborting Batch Transfer.');
  604.               end;
  605.           end;
  606.       end                         {sendmode=B and not in library and ok to send}
  607.     else if (ok_to_send) then
  608.       begin
  609.         SetSect(HomName);
  610.         Test_Download_Ratio(ok_to_send, fnum);
  611.         if ok_to_send then
  612.           begin
  613.             Xfrname := prompt('File name', 12, 'ES');
  614.             if Xfrname <> ' ' then
  615.               Xfrname := correct_fn(Xfrname)
  616.             else
  617.               Xfrname := '';
  618.             if Xfrname <> '' then
  619.               Send_a_File;
  620.             SetSect(HomName);
  621.             if (ok_to_send) and (Xfrname <> '') then
  622.               begin
  623.                 if in_arc then
  624.                   Update_Newin(ArcReq)
  625.                 else if in_library then
  626.                   Update_Newin(LibReq)
  627.                 else Update_Newin(Xfrname);
  628.               end;
  629.           end;
  630.       end
  631.     else if (not protocol_ok) then
  632.       begin
  633.         WriteLn(Com);
  634.         WriteLn(Com, 'Sorry, that protocol requires an MNP connection.')
  635.       end;
  636.   end;                            {Send Xmodem}
  637.   
  638.   
  639. end.                              { of DOWNLOAD.PAS}
  640. 
  641.